home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / srfi / srfi-39.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  4.8 KB  |  138 lines
  1. ;;; srfi-39.scm --- Parameter objects
  2.  
  3. ;;     Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
  4. ;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;;
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;;
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18.  
  19. ;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
  20. ;;; Date: 2004-05-05
  21.  
  22. ;;; Commentary:
  23.  
  24. ;; This is an implementation of SRFI-39 (Parameter objects).
  25. ;;
  26. ;; The implementation is based on Guile's fluid objects, and is, therefore,
  27. ;; thread-safe (parameters are thread-local).
  28. ;;
  29. ;; In addition to the forms defined in SRFI-39 (`make-parameter',
  30. ;; `parameterize'), a new procedure `with-parameters*' is provided.
  31. ;; This procedures is analogous to `with-fluids*' but taking as first
  32. ;; argument a list of parameter objects instead of a list of fluids.
  33. ;;
  34.  
  35. ;;; Code:
  36.  
  37. (define-module (srfi srfi-39)
  38.   #:use-module (ice-9 syncase)
  39.   #:use-module (srfi srfi-16)
  40.  
  41.   #:export (make-parameter)
  42.   #:export-syntax (parameterize)
  43.  
  44.   ;; helper procedure not in srfi-39.
  45.   #:export (with-parameters*)
  46.   #:replace (current-input-port current-output-port current-error-port))
  47.  
  48. ;; Make 'srfi-39 available as a feature identifiere to `cond-expand'.
  49. ;;
  50. (cond-expand-provide (current-module) '(srfi-39))
  51.  
  52. (define make-parameter
  53.   (case-lambda
  54.     ((val) (make-parameter/helper val (lambda (x) x)))
  55.     ((val conv) (make-parameter/helper val conv))))
  56.  
  57. (define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value
  58. (define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
  59.  
  60. (define (make-parameter/helper val conv)
  61.   (let ((value (make-fluid))
  62.         (conv conv))
  63.     (begin
  64.       (fluid-set! value (conv val))
  65.       (lambda new-value
  66.         (cond
  67.          ((null? new-value) (fluid-ref value))
  68.          ((eq? (car new-value) get-fluid-tag) value)
  69.          ((eq? (car new-value) get-conv-tag) conv)
  70.          ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
  71.          (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
  72.  
  73. (define-syntax parameterize
  74.   (syntax-rules ()
  75.     ((_ ((?param ?value) ...) ?body ...)
  76.      (with-parameters* (list ?param ...)
  77.                        (list ?value ...)
  78.                        (lambda () ?body ...)))))
  79.  
  80. (define (current-input-port . new-value)
  81.   (if (null? new-value)
  82.       ((@ (guile) current-input-port))
  83.       (apply set-current-input-port new-value)))
  84.  
  85. (define (current-output-port . new-value)
  86.   (if (null? new-value)
  87.       ((@ (guile) current-output-port))
  88.       (apply set-current-output-port new-value)))
  89.  
  90. (define (current-error-port . new-value)
  91.   (if (null? new-value)
  92.       ((@ (guile) current-error-port))
  93.       (apply set-current-error-port new-value)))
  94.  
  95. (define port-list
  96.   (list current-input-port current-output-port current-error-port))
  97.  
  98. ;; There are no fluids behind current-input-port etc, so those parameter
  99. ;; objects are picked out of the list and handled separately with a
  100. ;; dynamic-wind to swap their values to and from a location (the "value"
  101. ;; variable in the swapper procedure "let").
  102. ;;
  103. ;; current-input-port etc are already per-dynamic-root, so this arrangement
  104. ;; works the same as a fluid.  Perhaps they could become fluids for ease of
  105. ;; implementation here.
  106. ;;
  107. ;; Notice the use of a param local variable for the swapper procedure.  It
  108. ;; ensures any application changes to the PARAMS list won't affect the
  109. ;; winding.
  110. ;;
  111. (define (with-parameters* params values thunk)
  112.   (let more ((params params)
  113.          (values values)
  114.          (fluids '())     ;; fluids from each of PARAMS
  115.          (convs  '())     ;; VALUES with conversion proc applied
  116.          (swapper noop))  ;; wind/unwind procedure for ports handling
  117.     (if (null? params)
  118.     (if (eq? noop swapper)
  119.         (with-fluids* fluids convs thunk)
  120.         (dynamic-wind
  121.         swapper
  122.         (lambda ()
  123.           (with-fluids* fluids convs thunk))
  124.         swapper))
  125.     (if (memq (car params) port-list)
  126.         (more (cdr params) (cdr values)
  127.           fluids convs
  128.           (let ((param (car params))
  129.             (value (car values))
  130.             (prev-swapper swapper))
  131.             (lambda ()
  132.               (set! value (param value))
  133.               (prev-swapper))))
  134.         (more (cdr params) (cdr values)
  135.           (cons ((car params) get-fluid-tag) fluids)
  136.           (cons (((car params) get-conv-tag) (car values)) convs)
  137.           swapper)))))
  138.